home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / INTERFACE / Hyper-Display-Demo.lisp < prev    next >
Encoding:
Internet Message Format  |  1990-06-26  |  15.1 KB  |  [TEXT/CCL ]
  1. Subject: ccl;INTERFACE:Hyper-Display-Demo.lisp
  2. Received: from apple.com by goofy.apple.com with SMTP (5.61/25-eef)        id AA15414; Tue, 26 Jun 90 09:52:35 -0700        for Zukoski1@HyperMail.apple.com
  3. Received: from dime.cs.umass.edu by apple.com with SMTP (5.61/25-eef)        id AA25380; Tue, 26 Jun 90 09:52:29 -0700        for Zukoski1@HyperMail.apple.com
  4. Received: from vax1.cs.umass.edu by dime.cs.umass.edu (5.61/Ultrix2.0-B)        id AA04358; Tue, 26 Jun 90 12:51:59 -0400
  5. Date: Tue, 26 Jun 90 12:48 EST
  6. From: "Dan Suthers (413) 665-8929" <SUTHERS@cs.umass.EDU>
  7. Subject: ccl;INTERFACE:Hyper-Display-Demo.lisp
  8. To: Zukoski1
  9. Message-Id: <7394DE013CBF80117B@cs.umass.EDU>
  10. X-Envelope-To: Zukoski1@HyperMail.Apple.COM
  11. X-Vms-To: IN%"Zukoski1@HyperMail.Apple.COM"
  12. X-Vms-Cc: SUTHERS
  13. Received: by HyperMail from goofy.apple.com with smtp id 3605; Tue, 26 Jun 90 09:57:56 PDT
  14. Received: by Zukoski1 id 15973; Tue, 26 Jun 1990 13:31:59 PST
  15.  
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ; File:         Hyper-Demo.lisp
  18. ; Author:       Dan Suthers
  19. ; Created:      02-July-89 14:27:32
  20. ; Modified:     26-Jun-90 12:38:58 (Dan Suthers)
  21. ; Language:     Common Lisp
  22. ; Package:      hyper-display
  23. ;
  24. ; Description:  Demonstrates the Hyper-Display by putting up a short
  25. ;               text (a diagnostic summary in the domain of psycho-
  26. ;               educational assessment) with hypertext access to further
  27. ;               detail and definitions.
  28. ;
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31. (in-package :hyper-display)
  32.  
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. ;;;                                CODE
  35. ;;; All this is general, and could be copied and used for an application.
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37.  
  38. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39. ;;; Command definitions.  (Functions are embedded in lambdas because they
  40. ;;; reference the command list recursively.)
  41.  
  42. (defparameter *COMMANDS*
  43.   (list (list #\d "Define this."       
  44.               #'(lambda (hs w) (definer hs w)))
  45.         (list #\e "Expand on this." 
  46.               #'(lambda (hs w) (expander hs w)))
  47.         (list #\r "Return to previous text."
  48.               #'(lambda (hs w) (declare (ignore hs))
  49.                  (pop-structure w)))
  50.         (list #\i "Inspect Structure." 
  51.               #'(lambda (hs w) (declare (ignore w)) 
  52.                  (inspect hs)))))
  53.  
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. ;;; Display windows.  Must be defined after *commands* but before functions.
  56.  
  57. (eval-when (eval compile load)
  58.  
  59.   (defparameter *DEFINITION-WINDOW* 
  60.     (create-hyper-display  (make-hyper-structure)
  61.                            *commands*
  62.                            :window-size (make-point 450 120)
  63.                            :right-margin 53
  64.                            :window-position (make-point 2 260)
  65.                            :window-title "Definitions"))
  66.  
  67.   (defparameter *TEXT-WINDOW*
  68.     (create-hyper-display (make-hyper-structure)
  69.                           *commands*
  70.                           :window-title "Psycho-Educational Assessment"
  71.                           :window-size (make-point 450 200)
  72.                           :right-margin 60
  73.                           :window-position 
  74.                           (make-point 2 *menubar-bottom*)))
  75.  
  76.   )
  77.  
  78. (defun DEFINER (hs w)
  79.   (declare (ignore w))
  80.   (if (eq :term (first (hyper-structure-object hs)))
  81.     (let ((obj (second (hyper-structure-object hs))))
  82.       (if (and (symbolp obj)
  83.                (hyper-structure-p (get obj :definition)))
  84.         (push-to-structure (get obj :definition) *definition-window*)
  85.         (wind:message-dialogue 
  86.          "This term should have a definition, but I can't find it.")))
  87.     (wind:message-dialogue
  88.      "Your selection isn't a term (cannot have a definition).")))
  89.  
  90. (defun EXPANDER (hs w)
  91.   (if (member (first (hyper-structure-object hs)) 
  92.               '(:definition :phrase :statement))
  93.     (let ((obj (second (hyper-structure-object hs))))
  94.       (if (and (symbolp obj)
  95.                (hyper-structure-p (get obj :expansion)))
  96.         (push-to-structure (get obj :expansion) w)
  97.         (wind:message-dialogue 
  98.          "I can't find more detail on your selection."
  99.          )))
  100.     (wind:message-dialogue 
  101.      "Your selection isn't a phrase or statement (can't be expanded into more detail)."
  102.      )))
  103.  
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105. ;;; Display management.  
  106.  
  107. ;;; Definitions displayed in dedicated window, replacing previous contents.
  108. ;;; Existing code handles it.
  109.  
  110. ;;; Expansions get displayed in the same window, with option to pop to
  111. ;;; previous context.
  112.  
  113. (defun PUSH-TO-STRUCTURE (text-structure hd-window)
  114.   (declare (object-variable hyper-structure))
  115.   (setf (hyper-structure-parent text-structure) 
  116.         (ask hd-window hyper-structure))
  117.   (display-hyper-structure text-structure hd-window))
  118.  
  119. (defun POP-STRUCTURE (hd-window)
  120.   (declare (object-variable hyper-structure))
  121.   (let ((parent (hyper-structure-parent (ask hd-window hyper-structure))))
  122.     (if parent
  123.       (display-hyper-structure parent hd-window)
  124.       (wind:message-dialogue "There is no parent text to return to."))))
  125.  
  126. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127. ;;;                              DEMO TEXT
  128. ;;; The following is domain-specific text, for the purposes of this demo.
  129. ;;; Normally this stuff might be automatically generated as needed from 
  130. ;;; internal knowledge-base structures.
  131. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  132. ;;; Statements
  133.  
  134. (defparameter *TOP-LEVEL-SUMMARY*
  135.   (let* (
  136.          (f3p 
  137.           (make-hyper-structure :text-specs '("Factor-3 Profile")
  138.                                 :object '(:term factor-3-profile)))
  139.          (WR
  140.           (make-hyper-structure :text-specs '("WISC-R")
  141.                                 :object '(:term wisc-r)))
  142.          (interp-WR 
  143.           (make-hyper-structure 
  144.            :text-specs (list "First I interpreted the " 
  145.                              WR
  146.                              ", identifying a "
  147.                              f3p
  148.                              ".")
  149.            :object '(:statement interp-wr)))
  150.          (ADD 
  151.           (make-hyper-structure :text-specs '("A.D.D.")
  152.                                 :object '(:term add)))
  153.          (suggest-ADD 
  154.           (make-hyper-structure 
  155.            :text-specs (list "This suggested the "
  156.                              ADD
  157.                              " hypothesis")
  158.            :object '(:statement suggest-add)))
  159.          (other-obs
  160.           (make-hyper-structure :text-specs '("other inconsistent observations")
  161.                                 :object '(:phrase other-obs)))
  162.          (eval-reject-ADD 
  163.           (make-hyper-structure 
  164.            :text-specs (list "which I evaluated but rejected due to "
  165.                              other-obs
  166.                              ".")
  167.            :object '(:phrase eval-reject-add)))
  168.          (emotional-factors 
  169.           (make-hyper-structure :text-specs '("emotional factors")
  170.                                 :object '(:phrase emotional-factors)))
  171.          (bore-hyper
  172.           (make-hyper-structure :text-specs '("boredom-induced hyperactivity")
  173.                                 :object '(:phrase bore-hyper)))
  174.          (diagnosis
  175.           (make-hyper-structure 
  176.            :text-specs (list "My diagnosis is a combination of "
  177.                              emotional-factors
  178.                              " and "
  179.                              bore-hyper
  180.                              ".")
  181.            :object '(:statement diagnosis)))
  182.          (summary
  183.           (make-hyper-structure 
  184.            :text-specs (list "Diagnostic Summary: "
  185.                              interp-WR 
  186.                              " "
  187.                              suggest-ADD
  188.                              ", "
  189.                              eval-reject-ADD
  190.                              " "
  191.                              diagnosis)
  192.            :object '(:statement summary))))
  193.     (setf (hyper-structure-parent f3p) interp-WR) 
  194.     (setf (hyper-structure-parent WR) interp-WR)
  195.     (setf (hyper-structure-parent interp-WR) summary)
  196.     (setf (hyper-structure-parent ADD) suggest-ADD)
  197.     (setf (hyper-structure-parent suggest-ADD) summary)
  198.     (setf (hyper-structure-parent other-obs) eval-reject-ADD)
  199.     (setf (hyper-structure-parent eval-reject-ADD) summary)
  200.     (setf (hyper-structure-parent emotional-factors) diagnosis)
  201.     (setf (hyper-structure-parent bore-hyper) diagnosis)
  202.     (setf (hyper-structure-parent diagnosis) summary)
  203.     summary))
  204.  
  205. (setf 
  206.  (get 'SUGGEST-ADD :expansion)
  207.  ;; I need generators for structures reused, since each should be unique.  But
  208.  ;; each unique structure needs backpointer to yet-to-be created suggest-add.
  209.  ;; Solution is to keep track.
  210.  (let ((children-of-suggest-add nil))
  211.    (flet ((f3p-gen ()
  212.                    (push 
  213.                     (make-hyper-structure :text-specs '("Factor-3 Profile")
  214.                                           :object '(:term factor-3-profile))
  215.                     children-of-suggest-add)
  216.                    (first children-of-suggest-add))
  217.           (ADD-gen ()
  218.                    (push 
  219.                     (make-hyper-structure :text-specs '("A.D.D.")
  220.                                           :object '(:term add))
  221.                     children-of-suggest-add)
  222.                    (first children-of-suggest-add))
  223.           (f3s-gen ()
  224.                    (push 
  225.                     (make-hyper-structure :text-specs '("Factor-3 Subscale")
  226.                                           :object '(:term factor-3-subscale))
  227.                     children-of-suggest-add)
  228.                    (first children-of-suggest-add))
  229.           (stm-gen ()
  230.                    (push 
  231.                     (make-hyper-structure :text-specs '("short-term memory")
  232.                                           :object '(:term stm))
  233.                     children-of-suggest-add)
  234.                    (first children-of-suggest-add)))
  235.      (let ((suggest-add
  236.             (make-hyper-structure 
  237.              :text-specs 
  238.              (list
  239.               (f3p-gen)
  240.               " is evidence for "
  241.               (add-gen)
  242.               " for the following reason. "
  243.               "All three subscales on the "
  244.               (f3s-gen)
  245.               " involve retention of information in "
  246.               (stm-gen)
  247.               " while carrying out the task. "
  248.               "A person with an attentional deficit is likely to be distracted by other thoughts or external stimuli,"
  249.               " which replace the information in "
  250.               (stm-gen)
  251.               ". The disruption of "
  252.               (stm-gen)
  253.               " makes it difficult for such persons to complete the tasks on the "
  254.               (f3s-gen)
  255.               ", so "
  256.               (add-gen)
  257.               " is suspected when these scores are depressed."
  258.               "(see definition of "
  259.               (f3p-gen)
  260.               ").")
  261.              :object '(:statement suggest-add))))
  262.        (dolist (c children-of-suggest-add)
  263.          (setf (hyper-structure-parent c) suggest-add))
  264.        suggest-add))))
  265.  
  266. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  267. ;;; Definitions
  268.  
  269. (setf 
  270.  (get 'ADD :definition)
  271.  (make-hyper-structure 
  272.   :text-specs 
  273.   '("A.D.D.: Attention Deficit Disorder.")
  274.   :object '(:definition add)))
  275.  
  276. (setf 
  277.  (get 'ADD :expansion)
  278.  (let* ((dsm-iii
  279.          (make-hyper-structure 
  280.           :text-specs '("DSM-III")
  281.           :object '(:definition dsm-iii)))
  282.         (add
  283.          (make-hyper-structure 
  284.           :text-specs 
  285.           (list "Attention Deficit Disorder (A.D.D.) is a diagnostic category of the "
  286.                 DSM-iii
  287.                 ". It is defined to be present when ...")
  288.           :object '(:definition add))))
  289.    (setf (hyper-structure-parent dsm-iii) add)
  290.    add))
  291.  
  292. (setf
  293.  (get 'APTITUDE-TEST :definition)
  294.  (let* (
  295.         (psychometric
  296.          (make-hyper-structure :text-specs '("psychometric test")
  297.                                :object '(:term psychometric)))
  298.         (achievement
  299.          (make-hyper-structure :text-specs '("achievement")
  300.                                :object '(:term achievement)))
  301.         (apt-test
  302.          (make-hyper-structure 
  303.           :text-specs (list "Aptitude Test: a "
  304.                             psychometric
  305.                             " which is designed to measure inherent intellectual ability and potential,"
  306.                             "  as opposed to "
  307.                             achievement
  308.                             " (learned behaviors).")
  309.           :object '(:definition aptitude-test))))
  310.    (setf (hyper-structure-parent psychometric) apt-test)
  311.    (setf (hyper-structure-parent achievement) apt-test)
  312.    apt-test))
  313.  
  314. (setf 
  315.  (get 'DSM-III :definition)
  316.  (make-hyper-structure 
  317.   :text-specs 
  318.   '("DSM-III: Diagnostic and Statistical Manual, which defines categories of psychological disorders.")
  319.   :object '(:definition dsm-iii)))
  320.  
  321. (setf 
  322.  (get 'FACTOR-3-PROFILE :definition)
  323.  (let* ((WR
  324.          (make-hyper-structure :text-specs '("WISC-R")
  325.                                :object '(:term wisc-r)))
  326.         (coding
  327.          (make-hyper-structure :text-specs '("Coding")
  328.                                :object '(:term coding)))
  329.         (digit-span
  330.          (make-hyper-structure :text-specs '("Digit Span")
  331.                                :object '(:term digit-span)))
  332.         (arithmetic
  333.          (make-hyper-structure :text-specs '("Arithmetic")
  334.                                :object '(:term arithmetic)))
  335.         (f3p
  336.          (make-hyper-structure 
  337.           :text-specs 
  338.           (list "Factor-3 Profile: A pattern of results on the "
  339.                 WR
  340.                 " test. "
  341.                 "This pattern is present when three subscales ("
  342.                 Coding
  343.                 ", "
  344.                 Digit-Span
  345.                 ", and "
  346.                 Arithmetic
  347.                 ") are significantly depressed relative to the other 9 subscales.")
  348.           :object '(:definition factor-3-profile))))
  349.    (setf (hyper-structure-parent WR) f3p)
  350.    (setf (hyper-structure-parent coding) f3p)
  351.    (setf (hyper-structure-parent digit-span) f3p)
  352.    (setf (hyper-structure-parent arithmetic) f3p)
  353.    f3p))
  354.  
  355. (setf 
  356.  (get 'PSYCHOMETRIC :definition)
  357.  (make-hyper-structure 
  358.   :text-specs 
  359.   '("Psychometric test: a test designed to measure some psychological characteristic.")
  360.   :object '(:definition psychometric)))
  361.  
  362. (setf
  363.  (get 'WISC-R :definition)
  364.  (let* (
  365.         (apt-test
  366.          (make-hyper-structure :text-specs '("aptitude test")
  367.                                :object '(:term aptitude-test)))
  368.         (definition
  369.           (make-hyper-structure 
  370.            :text-specs (list
  371.                         "WISC-R: Weschler Intelligence Scale for Children, Revised. "
  372.                         "A widely used "
  373.                         apt-test
  374.                         ".")
  375.            :object '(:definition wisc-r)))
  376.         )
  377.    (setf (hyper-structure-parent apt-test) definition)
  378.    definition))
  379.  
  380. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  381. ;;; Get things started.
  382.  
  383. (display-hyper-structure *top-level-summary* *text-window*)
  384.  
  385. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  386. ;;; The End.
  387.